perm filename 12TONE.F4[TLC,MUS] blob
sn#074726 filedate 1973-11-25 generic text, type T, neo UTF8
00100 C ********** MATRIX FEB. 16,73 ******** PRINTS 12-TONE CHART ******
00200 C 'S'EARCH WILL LOCATE ROW SOURCES OF CHORDS, ETC.
00300 DIMENSION INV(12),IR(12),N(12),J(13,13),ISCAL(12),IS2(12),
00400 1 INP2(72),INP(72)
00500 1,IC(6),ISQ(25,25),NAME(10),INOT(49),JA(12)
00600 DATA ISCAL/'C','C#','D','D#','E','F','F#','G','G#',
00700 1 'A','A#','B'/,INV/'I1','I2','I3','I4','I5','I6','I7',
00800 1 'I8','I9','I10','I11','I12'/,IR/'R1','R2','R3','R4',
00900 1 'R5','R6','R7','R8','R9','R10','R11','R12'/
01000 CC 1 'R5','R6','R7','R8','R9','R10','R11','R12'/,IV/-1/
01100 DATA IS2/'C','$','D','$','E','F','$','G','$','A','$','B'/
01200 662 TYPE 61
01300 ACCEPT 1,NRW
01400 IF(NRW.EQ.'P')GO TO 62
01500 IF(NRW.EQ.'T')GO TO 1188
01600 IF(NRW.NE.'S')GO TO 64
01700 663 TYPE 65
01800 GO TO 661
01900 65 FORMAT(' TYPE NOTES'/)
02000 61 FORMAT(' NEW ROW, TYPE, PRINT OR SEARCH?'/)
02100 300 FORMAT(' PRINT HOW MANY?'/)
02200 200 FORMAT(' TYPE NAME'/)
02300 62 KREP=0
02400 CC IF(IV)GO TO 1188
02500 TYPE 300
02600 ACCEPT 400,KREP
02700 1188 KREP=KREP-1
02800 CC IV=0
02900 JOUT=3
03000 IF(NRW.EQ.'T')JOUT=5
03100 GO TO 288
03200 64 HEX=-10
03300 TYPE 200
03400 J(2,1)=INV(1)
03500 J(1,2)=IR(1)
03600 ACCEPT 444,NAME
03700 188 TYPE 100
03800 661 JOUT=5
03900 CC PRINT=0
04000 CC NOPRIN=-1
04100 FIRST=-1.
04200 ACCEPT 1,INP2
04300 CC IF(INP(1).NE.'S')GO TO 198
04400 IF(NRW.EQ.'S')GO TO 498
04500 DO 665 KGZ=1,72
04600 665 INP(KGZ)=INP2(KGZ)
04700 GO TO 198
04800 CC IF(INP(2).EQ.'P')PRINT=-1.
04900 CC664 IF(NRW.EQ.'P')PRINT=-1.
05000 C IF A 13TH NOTE IS ADDED, THEN NO PRINTOUT.
05100 C TYPE 'S' TO SEARCH, 'SP' OUTPUTS TO LPT.
05200 CC498 K=2
05300 498 K=0
05400 JS=0
05500 ISQ2=0
05600 CC IF(PRINT.EQ.0)GO TO 298
05700 CC WRITE(JOUT, 60)
05800 CC WRITE(JOUT, 60),NAME
05900 CC WRITE(JOUT, 60)
06000 CC WRITE(JOUT, 1),K,(INP(LL),LL=1,71)
06100 298 K=K+1
06200 DID=0
06300 IF(K.GT.72)GO TO 8888
06400 L=INP2(K)
06500 IF(L.EQ.' ')GO TO 298
06600 DO 888 M=1,12
06700 IF(L.NE.IS2(M))GO TO 888
06800 LL=M
06900 K=K+1
07000 IF(INP2(K).EQ.'S')LL=M+1
07100 IF(INP2(K).EQ.'F')LL=M-1
07200 ISQ2=ISQ2+2**LL
07300 C ASSIGNS # TO EACH NOTE
07400 JS=JS+1
07500 C JS IS # OF NOTES IN GROUP TO BE FOUND.
07600 GO TO 298
07700 888 CONTINUE
07800 8888 IF(JS.EQ.0)CALL EXIT
07900 C NO NOTES WERE GIVEN.
08000 IF(FIRST)LGRP=JS
08100 FIRST=0
08200 C SAVE # OF NOTES TO BE FOUND.
08300 JGRP=JS-1
08400 DO 333 NN=1,2
08500 CC DO 333 K=2,13
08600 DO 333 K=1,13
08700 C '+JGRP' IS FOR WRAP-AROUND
08800 JQ=2
08900 DO 222 L=1,12
09000 KQ=L
09100 C SETS # OF 1ST NOTE OF FOUND GROUP.
09200 LL=0
09300 DO 223 KK=JQ,JQ+JGRP
09400 NR=KK
09500 NI=K
09600 IF(NN.EQ.1)GO TO 223
09700 NR=K
09800 NI=KK
09900 223 LL=LL+ISQ(NR,NI)
10000 2223 IF(LL.EQ.ISQ2)GO TO 334
10100 222 JQ=JQ+1
10200 GO TO 333
10300 334 NR=1
10400 IF(LGRP.NE.JS)TYPE 67,JS
10500 LGRP=JS
10600 C NN=1, R FORMS. NN=2, I FORMS.
10700 IF(NN.EQ.1)GO TO 2334
10800 NI=1
10900 NR=K
11000 C K WILL BE 1ST NOTE OF GROUP IN ROW.
11100 2334 WRITE(JOUT, 66),J(NR,NI),KQ
11200 DID=-1.
11300 333 CONTINUE
11400 IF(DID)GO TO 3333
11500 CC IF(JGRP.EQ.1)GO TO 188
11600 IF(JGRP.NE.1)GO TO 3334
11700 C DON'T TRY AGAIN IF GROUP IS DOWN TO 2.
11800 TYPE 67,JGRP
11900 GO TO 3333
12000 3334 DO 398 K=72,1,-1
12100 IF(INP2(K).EQ.' ')GO TO 398
12200 3398 INP2(K)=' '
12300 INP2(K-1)=' '
12400 GO TO 498
12500 398 CONTINUE
12600 C ABOVE SHORTENS GROUP BY ONE.
12700 3333 TYPE 60
12800 GO TO 662
12900 198 JJ=1
13000 K=0
13100 98 K=K+1
13200 IF(K.GT.72)GO TO 9999
13300 L=INP(K)
13400 IF(L.EQ.' ')GO TO 98
13500 IF(JJ.EQ.14)GO TO 99
13600 C ANYTHING TYPED AFTER 12 NOTES CAUSES 'NOPRIN'.
13700 DO 999 M=1,12
13800 IF(L.NE.IS2(M))GO TO 999
13900 LL=M
14000 K=K+1
14100 IF(INP(K).EQ.'S')LL=M+1
14200 IF(INP(K).EQ.'F')LL=M-1
14300 JA(JJ)=LL
14400 C SAVES #S FOR NOTATION
14500 JJ=JJ+1
14600 J(JJ,2)=LL
14700 ISQ(JJ,2)=2**LL
14800 C SETS VALUE AS POWER OF 2 FOR EACH NOTE.
14900 GO TO 98
15000 999 CONTINUE
15100 CC99 NOPRIN=-1
15200 99 CONTINUE
15300
15400 9999 IF(JJ.EQ.1)CALL EXIT
15500 C NO NOTES WERE GIVEN.
15600 I=J(2,2)
15700 C WORKS OUT MATRIX
15800 DO 9 K=3,13
15900 LL=J(K,2)-I+1
16000 IF(LL.LE.0)LL=LL+12
16100 9 J(K,1)=INV(LL)
16200 DO 2 K=2,12
16300 2 N(K)=J(K+1,2)-I
16400 DO 3 K=3,13
16500 LL=I-N(K-1)
16600 IF(LL.LT.1)LL=LL+12
16700 IF(LL.GT.12)LL=LL-12
16800 ISQ(2,K)=2**LL
16900 J(2,K)=LL
17000 LL=LL+1-I
17100 IF(LL.LE.0)LL=LL+12
17200 3 J(1,K)=IR(LL)
17300 DO 4 K=3,13
17400 DO 4 I=3,13
17500 LL=J(2,I)+N(K-1)
17600 IF(LL.LT.1)LL=LL+12
17700 IF(LL.GT.12)LL=LL-12
17800 ISQ(K,I)=2**LL
17900 4 J(K,I)=ISCAL(LL)
18000 DO 7 K=2,13
18100 7 J(K,2)=ISCAL(J(K,2))
18200 DO 8 K=3,13
18300 8 J(2,K)=ISCAL(J(2,K))
18400 10 J(1,1)=0
18500 DO 28 K=2,13
18600 DO 28 L=2,13
18700 KQ=ISQ(K,L)
18800 ISQ(K+12,L)=KQ
18900 28 ISQ(K,L+12)=KQ
19000 C +12 FOR WRAP-AROUND
19100 CC288 IF(NOPRIN)GO TO 111
19200 288 WRITE(JOUT, 60),NAME
19300 WRITE(JOUT, 60)
19400 C NEXT JUMPS OVER NOTATION PRINT.
19500 GO TO 5557
19600 C UNTIL 210, PRINTS NOTATION
19700 G=' '
19800 WRITE(JOUT, 201),G
19900 L=5
20000 DO 202 IJ=1,7
20100 LN=-1
20200 IF(IJ.EQ.2.OR.IJ.EQ.4.OR.IJ.EQ.6)LN=0
20300 C LINE OR SPACE
20400 JK=2
20500 IF(IJ.EQ.1.OR.IJ.EQ.4)JK=1
20600 DO 203 IQ=1,JK
20700 204 DO 205 K=1,49
20800 205 INOT(K)=' '
20900 DO 206 K=1,12
21000 IF(JA(K).NE.L)GO TO 206
21100 C SKIPS IF NO NOTE NOW
21200 IK=K
21300 L=L-1
21400 IF(L.EQ.0)L=12
21500 M=K*4-1
21600 IF(IK.GT.6)M=M+2
21700 2000 INOT(M)='O'
21800 IF(L.EQ.3.OR.L.EQ.1.OR.L.EQ.10.OR.L.EQ.8.OR.
21900 1 L.EQ.6)INOT(M-1)='#'
22000 IF(L.EQ.2.OR.L.EQ.12.OR.L.EQ.9.OR.L.EQ.7.OR.
22100 1 L.EQ.5)LN=0
22200 GO TO 208
22300 206 CONTINUE
22400 208 IF(LN)WRITE(JOUT, 209),(INOT(IZ),IZ=1,M)
22500 C OVERPRINTS
22600 203 IF(LN.EQ.0)WRITE(JOUT, 210),(INOT(IZ),IZ=1,M)
22700 G=' '
22800 IF(IJ.EQ.5)G='G'
22900 202 IF(IJ.NE.2.AND.IJ.NE.4.AND.IJ.NE.6)WRITE(JOUT, 201),G
23000 201 FORMAT(2XA1,52('-'))
23100 209 FORMAT(4X49A1)
23200 210 FORMAT('+',4X49A1)
23300 C PRINTS LINES FOR SCRATCH.
23400
23500 5557 WRITE(JOUT, 60)
23600 J(1,1)=' '
23700 WRITE(JOUT, 5),J
23800 CC WRITE(JOUT, 60)
23900 IF(JOUT.EQ.5)PAUSE
24000 111 CONTINUE
24100 DO 1111 K=1,6
24200 1111 IC(K)=0
24300 LR=1
24400 JGRP=6
24500 KGRP=2
24600 MPRINT=2
24700 DO 1000 IGRP=1,4
24800 KK=0
24900 DO 17 K=1,12,JGRP
25000 JJ=0
25100 DO 117 L=1,JGRP
25200 117 JJ=JJ+ISQ(K+L,2)
25300 KK=KK+1
25400 17 IC(KK)=JJ
25500 MM=0
25600 MCNT=0
25700 DO 19 NN=1,2
25800 JQQ=4-NN
25900 DO 19 I=JQQ,13
26000 DO 21 KK=1,KGRP
26100 DO 18 K=1,12,JGRP
26200 JJ=0
26300 DO 118 L=1,JGRP
26400 NI=I
26500 NR=L+K
26600 IF(NN.EQ.1)GO TO 118
26700 NI=NR
26800 NR=I
26900 118 JJ=ISQ(NR,NI)+JJ
27000 LL=I
27100 GO TO 18
27200 WRITE(JOUT, 400),KK,JGRP,JJ,IGRP,KGRP,K
27300 18 IF(IC(KK).EQ.JJ)GO TO 21
27400 GO TO 19
27500 21 CONTINUE
27600 LI=LL
27700 LR=1
27800 IF(NN.EQ.1)GO TO 221
27900 LI=1
28000 LR=LL
28100 CC221 IF(MM.OR.NOPRIN)GO TO 55
28200 221 IF(MM)GO TO 55
28300 MPRINT=MPRINT+1
28400 C COUNTS FOR STAFF PRINTOUT
28500 GO TO (11,22,33,44),IGRP
28600 11 WRITE(JOUT, 51)
28700 HEX=0
28800 GO TO 55
28900 22 WRITE(JOUT, 52)
29000 HEX=-10
29100 GO TO 55
29200 33 WRITE(JOUT, 53)
29300 HEX=-10
29400 GO TO 55
29500 44 WRITE(JOUT, 54)
29600 HEX=-10
29700 55 MM=-1
29800 CC IF(NOPRIN)GO TO 19
29900 IF(HEX.EQ.5)WRITE(JOUT, 51)
30000 HEX=HEX+1
30100 MCNT=MCNT+1
30200 WRITE(JOUT, 50),J(LR,LI)
30300 IF(MCNT.LT.7)GO TO 19
30400 MCNT=0
30500 MM=0
30600 C TO STAY IN 8 1/2" WIDTH ON PAPER
30700 19 CONTINUE
30800 JGRP=JGRP-1
30900 IF(IGRP.EQ.1)JGRP=4
31000 1000 KGRP=12/JGRP
31100 KREP=KREP-1
31200 CC IF(NOPRIN)GO TO 188
31300 IF(JOUT.EQ.5)GO TO 662
31400 WRITE(JOUT, 60)
31500 L=5-MPRINT/2
31600 DO 5555 K=1,L
31700 5555 WRITE(JOUT, 5556)
31800 IF(KREP)CALL EXIT
31900 WRITE(JOUT, 500)
32000 GO TO 10
32100 5556 FORMAT(/5(1X,80('-')/)/)
32200 51 FORMAT(/' HEXADS ....R1',$)
32300 52 FORMAT(/' TETRADS ...R1',$)
32400 53 FORMAT(/' TRIADS ....R1',$)
32500 54 FORMAT(/' DYADS .....R1',$)
32600 5 FORMAT(1XA4,2(1X6A4)/2(/6(1XA4,2(1X6A4)/)))
32700 1 FORMAT (72A1)
32800 444 FORMAT (10A5)
32900 50 FORMAT('+ = ',A3,$)
33000 60 FORMAT(1X10A5)
33100 66 FORMAT(1XA5,I2,3XI2)
33200 67 FORMAT(' GROUP SHORTENED TO ',I2)
33300 100 FORMAT(' TYPE 12 NOTES'/)
33400 500 FORMAT('1')
33500 400 FORMAT(6I)
33600 END